home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops ƒ / Base < prev    next >
Text File  |  1993-02-02  |  13KB  |  496 lines
  1. \ Nov 88 mrh    Mops version.
  2. \ May 90 mrh    Changed to trap$ and fdos$ so we will work on 680x0 with
  3. \        instruction cache.
  4. \        Select{ no longer requires default{ - for Neon compatibility.
  5. \ Sept 92 mrh    New words etc. moving closer to ANSI standard
  6.  
  7. false    value    ECHO?        \ echo load to screen?
  8.  
  9. \ We redefine a few useful words to take advantage of our optimization.
  10.  
  11. : 1+    ?comp  1 postpone literal  postpone +  ;    immediate
  12. : 2+    ?comp  2 postpone literal  postpone +  ;    immediate
  13. : 3+    ?comp  3 postpone literal  postpone +  ;    immediate
  14. : 4+    ?comp  4 postpone literal  postpone +  ;    immediate
  15.  
  16. : 1-    ?comp  1 postpone literal  postpone -  ;    immediate
  17. : 2-    ?comp  2 postpone literal  postpone -  ;    immediate
  18. : 3-    ?comp  3 postpone literal  postpone -  ;    immediate
  19. : 4-    ?comp  4 postpone literal  postpone -  ;    immediate
  20.  
  21. : 2*    ?comp  1 postpone literal  postpone <<  ;    immediate
  22. : 2/    ?comp  1 postpone literal  postpone >>  ;    immediate
  23. : 4*    ?comp  2 postpone literal  postpone <<  ;    immediate
  24. : 4/    ?comp  2 postpone literal  postpone >>  ;    immediate
  25.  
  26.  
  27. \ ANSI words
  28.  
  29. : CELL+    state IF  postpone 4+  else  4 +  THEN  ;    immediate
  30. : CELL-    state IF  postpone 4-  else  4 -  THEN  ;    immediate
  31. : CELLS    state IF  2 postpone literal  postpone <<  ELSE    2 <<  THEN  ;  immediate
  32. : CHAR+    state IF  postpone 1+  else  1 +  THEN  ;    immediate
  33. : CHARS    ;                        immediate
  34.  
  35. : RECURSE        curr-def  compile,  ;            immediate
  36.  
  37. : SAVE-INPUT
  38.     src-start  src-len  >in @  source-id  4  ;
  39.  
  40. : RESTORE-INPUT
  41.     dup 4 <>  IF  true  EXIT  THEN
  42.     drop
  43.     -> source-id  >in !  -> src-len  -> src-start  false  ;
  44.  
  45.  
  46. \ .H and U.H print a number in hex, signed and unsigned respectively.
  47.  
  48. : .H    base >r  hex   .  r> -> base  ;
  49. : U.H    base >r  hex  u.  r> -> base  ;
  50.  
  51.  
  52. \        =========================
  53.  
  54.     0    constant    Z
  55.  
  56. : NULLOSSTR        ['] z  ;
  57.  
  58.  
  59. : @WORD        \ ( -- addr )  Retrieves next blank-delimited word from input stream.
  60.     BL word  ;
  61.  
  62. : LIT        \ ( n -- )  A state-smart version of LITERAL.  Corresponds
  63.             \ to LITERAL in Fig-Forth or original Neon, whereas our
  64.             \ present LITERAL is Forth-83/ANSI.
  65.     state  IF  postpone literal  THEN  ;        immediate
  66.  
  67. : 0,  0 ,  ;        \ Compiles an empty cell
  68.  
  69. : @VAL    intrp1  ;    \ Compiles a number from input stream
  70.  
  71.  
  72. : 'TYPE        \ ( -- 4bytes )   OS type literal
  73.     pad 4 bl fill  @word count 4 min
  74.     pad swap cmove  pad @  postpone lit  ;    immediate
  75.  
  76. create BUF255  256 allot        \ buffer for string operations
  77.  
  78. : >STR255        \ ( addr len addr -- addr )
  79.                 \ Converts a string to a Str255 at addr
  80.     dup >r  place  r>  ;
  81.  
  82. : STR255    \ ( -- ^buf255 )
  83.     buf255 >str255  ;
  84.  
  85.  
  86. : $        \ State-smart HEX literal word
  87.     base >r
  88.     hex  Mword  number  postpone lit
  89.     r> -> base  ;            immediate
  90.  
  91.  
  92. : LITW        \ ( n -- )
  93.     $ 3D3C w,  w,  ;
  94.  
  95.  
  96. : W        intrp1  litw  ;        immediate
  97.  
  98.  
  99. \ Trap compilation.  We've changed the syntax from Neon's  $ xxxx TRAP
  100. \ to  TRAP$ xxxx.  This is because we are now compiling in-line trap
  101. \ calls, to avoid problems with self-modifying code, and also because Apple
  102. \ are now defining traps that way.
  103.  
  104. : SAVA5        postpone doSavA5  ;
  105.  
  106. : RSTA5
  107.     $ CD4F w,            \    exg    a6,a7
  108.     $ 2A5F w,  ;        \    move.l    (a7)+,a5
  109.  
  110. : (TRAP$)    \ ( trap# -- )  Compiles a call to the given trap.
  111.     SavA5  w,  RstA5  ;
  112.  
  113. : TRAP$        \ ( --<trap#> )
  114.     base >r
  115.     hex  intrp1  (trap$)
  116.     r> -> base  ;        immediate
  117.  
  118.  
  119. : (FDOS$)        \ ( trap# -- )
  120.     $ 205E w,                \    move.l    (a6)+,a0    ; FCB pointer
  121.     SavA5  w,  RstA5
  122.     $ 48C0 w,                \    ext.l    d0    ; Result
  123.     $ 2D00 w,  ;            \    move.l    d0,-(a6)
  124.  
  125.  
  126. : FDOS$        \ ( --<trap#> )
  127.     base >r
  128.     hex  intrp1  (fdos$)
  129.     r> -> base  ;        immediate
  130.  
  131.  
  132. \            ==================
  133.  
  134. : OpenResFile        \ ( addr len -- )  Opens named resource file
  135.     >r >r word0 r> r> str255
  136.     trap$ a997  i->l            \ call OpenResFile
  137.     -1 = abort" resource file open failed"  ;
  138.  
  139. : OPENMR            \ Opens the Mops system resource file if necessary.
  140.     MRopen?  ?exit                    \ Do nothing if already open
  141.     instld?  ?exit                    \ or if this is an installed application
  142.     " mops.rsrc" OpenResFile
  143.     true -> MRopen?  ;
  144.  
  145.  
  146. : CHAR        @word 1+ c@  ;                \ ANSI - replaces ASCII
  147. : [CHAR]    @word 1+ c@  postpone literal  ;    immediate
  148.  
  149. : &            \ ( -- c )  A shorter state-smart version.
  150.     @word 1+ c@  postpone lit  ;        immediate
  151.  
  152.  
  153. : GETSTRING        \ ( resID -- addr len )  Get the string with resource ID
  154.     openMR
  155.     0 swap makeint  trap$ a9ba        \ call getString
  156.     dup if  @ count  else  0  then  ;
  157.  
  158.  
  159. : (TSTR)            \ ( id# -- )  Prints string with given resID.
  160.     getString type  ;
  161.  
  162. : X    ['] (tstr) -> tstr  ;        \ We can't do -> outside a defn till Args loaded
  163. x  forget x
  164.  
  165.  
  166. \ Our normal error action is to call DIE with an error number.  DIE calls
  167. \ SvErr to save the error info, then THROWs the error number.  If no error
  168. \ handler has been installed, or only handlers which don't want that number
  169. \ and re-THROW it, the default action for THROW occurs.  This calls DFLT-DIE.
  170.  
  171. : (DDIE)            \ ( n -- )
  172.     setFwind
  173.     +echo   0 -> (err#)        \ Clear error indicator from AppleEvents
  174.     dflt-err  ;                \ Display error info and abort
  175.  
  176. : x    ['] (ddie) -> dflt-die  ;
  177. x  forget x
  178.  
  179.  
  180. : ?ERROR        \ ( b -- )  Aborts and prints resource string if true.
  181.                 \ Usage:  ?error 999
  182.     postpone if
  183.     intrp1  ( get err# )  postpone literal   postpone die
  184.     postpone then  ;        immediate
  185.  
  186.  
  187. : TYPE#        \ Prints string for id# in stream
  188.     intrp1  postpone lit   postpone (tStr)  ;    immediate
  189.  
  190.  
  191. : (.RSTR)    \ ( -- )  print "Msg# ..." then string with given resID
  192.     ." Msg# " dup . ." : "  (tStr)  ;
  193.  
  194.  
  195. : MSG#        \ ( -- )  print " Msg#" then string for id# in stream
  196.     intrp1  postpone lit  postpone (.rStr)  ;    immediate
  197.  
  198.  
  199. \        ============ Resources ===========
  200.  
  201.  
  202. : GETRES    \ ( type resID -- handle )
  203.     0 down makeint  trap$ a9a0  ;        \ call GetResource
  204.  
  205.  
  206. \ ( -- #cells)
  207.  
  208. : RDEPTH        rp0  rp@ - 4 / 2-  ;
  209.  
  210. : ?RDEPTH        rdepth  220 > ?error 116  ;
  211.  
  212.  
  213. \        ========== Type checking ===========
  214.  
  215. \ Sometimes we want to check that a non-object parameter to a word is of a 
  216. \ certain type.  We give it a unique type code and use TYPCHK.
  217.  
  218. : TYPCHK    <>  ?error 179  ;
  219.  
  220.  
  221. \        ========== Forward definitions ===========
  222.  
  223.  
  224. : X    setfWind +echo
  225.     cr ." From " r@ .id  2 spaces  r@ .h  109 die  ;
  226.  
  227.  
  228. : FORWARD
  229.     colHdr
  230.     $ 487AFFFE  ,                \    pea   (start of this instrn)
  231.     ['] x  here  6 allot
  232.     (patch)  ;
  233.  
  234. : :F    ?exec  301
  235.     here  '  (patch)  :noname  ;
  236.  
  237. : ;F    (;)  301 ?defn  ;        immediate
  238.  
  239.  
  240. forward    BLD        \ Used in CLASS.  Needs to be down here so we never
  241.                 \ refer to it with a short branch.  Kludge?
  242.  
  243. \ Commonly needed error words.  These are forward defined - the main
  244. \ application should provide a sensible definition, with a nice friendly
  245. \ alert box, to tell the user in a nice friendly way that things are up
  246. \ the creek.
  247.  
  248. forward    NOMEM        \ Call when (not if!) we run out of memory.
  249.  
  250. forward    I/O_ERR        \ ( err# -- )  Call when there's an I/O error.
  251.  
  252. : OK?        \ ( rc -- )  A useful word to use after an I/O op.
  253.     ?dup  0EXIT  I/O_err  ;
  254.  
  255.  
  256. \        ========= :PROC and ;PROC ============
  257.  
  258. : :PROC
  259.     colHdr  here  6 allot
  260.     ['] procEntry  swap  6  cmove
  261.     :noname  303  ;        immediate
  262.  
  263. : ;PROC        immediate
  264.     postpone procExit  (;)
  265.     303 ?defn  ;
  266.  
  267.  
  268. \     ======== Various utility words needed later =========
  269.  
  270. \ BECOME allows restarting at a given word, with all stacks
  271. \ empty.  This is necessary in menu handlers and other areas
  272. \ that could create indefinite nesting situations.
  273.  
  274. ' quit    vect    BECOMECFA
  275.  
  276. : BE    sp0 sp!  rp0 rp!  becomeCfa  quit  ;
  277.  
  278. : (BE)    -> becomeCfa be  ;
  279.  
  280.  
  281. : BECOME        \ Usage: Become newWord - compiles code to Be at runtime
  282.     state
  283.     IF        postpone [']  postpone (be)
  284.     ELSE    '  -> becomeCfa  be
  285.     THEN  ;            immediate
  286.  
  287.  
  288. : DATETIME
  289.     $ 20C  @  ;
  290.  
  291.  
  292. \        ============ Tables, lists etc. ===============
  293.  
  294. : )        123 die  ;    immediate        \ "} or } read when no list is current"
  295. : }        123 die  ;    immediate
  296.  
  297. : }OR)?        \ ( cfa -- cfa b )
  298.     dup  ['] }  =  over  ['] ) =  or  ;
  299.  
  300.  
  301. : TABLE
  302.     <BUILDS        0 w,  here  112
  303.     DOES>        length  ;
  304.  
  305. : END_TABLE
  306.     112 ?pairs
  307.     here over -            \ table length (excluding length field)
  308.     swap 2- w!  ;        \ store in length field
  309.  
  310.     0    value        CNT
  311.  
  312. : (LITS)        \ stack compiled list of values starting at IP
  313.     w@(ip)  ( count )  dup  -> cnt
  314.     4* r> tuck +  dup >r  swap
  315.     do  i @abs  4 +loop
  316.     cnt  ;
  317.  
  318.  
  319. : XTS{            \ State-smart word to compile or stack a list
  320.                 \ of xts.  Pulls words from stream, until "}".
  321.     state IF   postpone (lits)  here  0 w,  THEN
  322.     0
  323.     BEGIN   '   }or)?
  324.     NWHILE   state IF  reloc,  else  swap  THEN  1+
  325.     REPEAT
  326.     drop   state IF  swap w!  THEN  ;        immediate
  327.  
  328. : CFAS{    postpone xts{  ;    immediate        \ Synonyms for compatibility
  329. : CFAS(    postpone xts{  ;    immediate
  330.  
  331.  
  332. : RESERVE        \ ( len -- )  Allot and clear.
  333.     here over erase allot  ;
  334.  
  335.  
  336. \ SCON defines a string constant.  Usage:
  337. \
  338. \    scon    <name>    "a string"
  339. \
  340. \ Runtime: ( -- addr len )
  341. \
  342. \ Change from Neon: the first nonblank char after the name of the SCON
  343. \ becomes the delimiter.  So " can be used as usual, but anything else can
  344. \ be used instead, e.g.:
  345. \
  346. \    scon    <name>    /this string contains " as non-delimiter/
  347.  
  348. : SCON
  349.     <BUILDS        bl skip-src+
  350.                 src-start >in @ + c@  ,dlm-str
  351.     DOES>        count  ;
  352.  
  353.  
  354. \ CASE should be used for non-contiguous or dynamically computed values.
  355. \ This is a modified Eaker/Duncan model.
  356. \ Our optimization strategy gives quite good code.
  357.  
  358. : CASE        ?comp  302  ;        immediate
  359.  
  360. : OF
  361.     postpone over  postpone =  postpone if
  362.     postpone drop  ;            immediate
  363.  
  364. : RANGEOF
  365.     postpone within?  postpone if
  366.     postpone drop  ;            immediate
  367.  
  368. : ENDOF
  369.     postpone else  ;            immediate
  370.  
  371. : ENDCASE        immediate
  372.     postpone drop
  373.     BEGIN  dup 302 =  NWHILE  >resolve  REPEAT  drop  ;
  374.  
  375.  
  376. \ TYPE{ defines a Pascal/C-like enumerated type.  At this stage we don't give
  377. \ a name to the "type" as such, as we can't do anything really sensible with
  378. \ it.  However later we can optionally load the ENUM-TYPE class which is
  379. \ rather more Pascal-like.  But even without that, the enumeration is useful
  380. \ by itself.
  381.  
  382.     0    value    TYPECNT
  383.  
  384. ' null    vect    DO_ET        \ Hook for handling the ENUM-TYPE
  385.                             \ class when it's loaded
  386.                             
  387. : ENDLIST?        \ ( chr -- b )
  388.     latest n>count 1 =  down  c@ =  and
  389.     dup  IF  latest n>link  (forget)  THEN  ;
  390.  
  391.  
  392. : TYPE{
  393.     0 -> typeCnt                \ 1st value
  394.     BEGIN    typeCnt  constant  1 ++> typeCnt
  395.             & }  endlist?
  396.     UNTIL
  397.     do_ET  ;
  398.  
  399.  
  400. type{  InMainDic  InOtherMod  InThisMod  }        \ Relocatable addr types
  401.  
  402.  
  403. \ SELECT{  defines a positional case construct - see Forth Dimensions vII p.51.
  404. \  It is smaller and faster than the equivalent CASE construct, as long as
  405. \ there are more than a couple of values.  Values must be >= 0, and we give
  406. \ a warning if a value > 50 is used, which could well be a boo-boo.
  407.  
  408.    0    value        MAXINDEX
  409.  
  410. \ Begin an indexed case structure
  411.  
  412. : SELECT{
  413.     postpone (sel)
  414.     maxindex        \ Save on stack for nested selects
  415.     here            \ Marks position of rtn addr offset word
  416.     0 w,            \ Filled in later with RA offset
  417.     1            \ Dummy, so }SELECT knows when to stop
  418.     0 -> maxindex
  419.     postpone [  240  ;        immediate
  420.  
  421. : IS{                \ ( 240 index -- index here 240 )
  422.     ?exec  swap 240 ?pairs
  423.     dup 0<  ?error 102
  424.     dup  maxindex max  -> maxindex
  425.     maxindex 500 > if  msg# 85  then
  426.     here  240  postpone ]  ;        immediate
  427.  
  428. : }END
  429.     240 ?pairs
  430.     postpone (exit)  postpone [  240  ;        immediate
  431.  
  432. : DEFAULT{
  433.     240 ?pairs
  434.     here  241  postpone ]  ;        immediate
  435.  
  436. : }SELECT        \ ( ... index addr index addr (dflt-addr) 240/241 -- )
  437.     dup 240 =
  438.     IF        drop  here  $ 4E75 w,        \ No default - we make a dummy one
  439.     ELSE    241 ?pairs
  440.     THEN
  441.     -1 -> state   postpone (exit)
  442.     
  443.  \ Now build table:
  444.     maxindex 3+ 2* allot
  445.     ( ... dflt-addr )  here -  ( now relative to RA )
  446.     here 2-   here  maxindex 2* -  6 -
  447.     DO  ( fill table with dflt addr initially )
  448.         dup  i w!
  449.     2 +LOOP
  450.     drop  maxindex  here 2- w!
  451.     BEGIN    ( index addr )    dup 1 =
  452.     NWHILE
  453.         ( index addr )  here -  here rot 2* - 6 -  w!
  454.     REPEAT
  455.     drop  ( tbl-offs-pos )  here over -  swap w!
  456.     -> maxindex  ;            immediate
  457.  
  458. \ Testing:
  459. \ +echo
  460. \ : q db
  461. \    select{    3 is{ 23 }end
  462. \        2 is{ 22 }end
  463. \    default{ 999
  464. \    }select  ;
  465. \ key!
  466. \        ========== Error diagnostics ===========
  467.  
  468. \ We use special values for nil handles and nil pointers.  These are
  469. \ odd addresses in ROM, so that if we do a word or long access we will
  470. \ trap, and if we write a byte it at least won't go anywhere.
  471.  
  472.  
  473. : .RTN        \ ( addr -- )
  474.     cr ." From  $"  .h  4 spaces  ;
  475.  
  476. : RANGE_ERR    \ ( index range rtn-addr -- )
  477.     dup 1+ 0=  ?error 128            \ Spurious range error
  478.     .rtn
  479.     dup -1 <
  480.     IF        nip  ?error 130            \ Not an indexed class
  481.     ELSE    ." Range: " .  ."   Index: " .
  482.             true  ?error 129
  483.     THEN  ;
  484.  
  485.  
  486. \ If we do software mult and div (on a 68000 which only allows a 16-bit divisor or
  487. \ multiplicand) we also check for overflow and call ArithErr (vector) if ovfl occurs.  
  488. \ The appropriate err# is on the stack already, so here we just set ArithErr to Die.
  489. \ This can be redirected as needed.
  490.  
  491. : X    ['] range_err -> rngErr   ['] die  -> arithErr  ;
  492.  
  493. x   forget x
  494.  
  495. <" Args
  496.